home *** CD-ROM | disk | FTP | other *** search
- # Commands covered: proc, return, global
- #
- # This file contains a collection of tests for one or more of the Tcl
- # built-in commands. Sourcing this file into Tcl runs the tests and
- # generates output for errors. No output means no errors were found.
- #
- # Copyright (c) 1991-1993 The Regents of the University of California.
- # Copyright (c) 1994 Sun Microsystems, Inc.
- #
- # See the file "license.terms" for information on usage and redistribution
- # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
- #
- # @(#) proc.test 1.18 94/12/17 16:20:19
-
- if {[string compare test [info procs test]] == 1} then {source defs}
-
- proc tproc {} {return a; return b}
- test proc-1.1 {simple procedure call and return} {tproc} a
- proc tproc x {
- set x [expr $x+1]
- return $x
- }
- test proc-1.2 {simple procedure call and return} {tproc 2} 3
- test proc-1.3 {simple procedure call and return} {
- proc tproc {} {return foo}
- } {}
- test proc-1.4 {simple procedure call and return} {
- proc tproc {} {return}
- tproc
- } {}
-
- test proc-2.1 {local and global variables} {
- proc tproc x {
- set x [expr $x+1]
- return $x
- }
- set x 42
- list [tproc 6] $x
- } {7 42}
- test proc-2.2 {local and global variables} {
- proc tproc x {
- set y [expr $x+1]
- return $y
- }
- set y 18
- list [tproc 6] $y
- } {7 18}
- test proc-2.3 {local and global variables} {
- proc tproc x {
- global y
- set y [expr $x+1]
- return $y
- }
- set y 189
- list [tproc 6] $y
- } {7 7}
- test proc-2.4 {local and global variables} {
- proc tproc x {
- global y
- return [expr $x+$y]
- }
- set y 189
- list [tproc 6] $y
- } {195 189}
- catch {unset _undefined_}
- test proc-2.5 {local and global variables} {
- proc tproc x {
- global _undefined_
- return $_undefined_
- }
- list [catch {tproc xxx} msg] $msg
- } {1 {can't read "_undefined_": no such variable}}
- test proc-2.6 {local and global variables} {
- set a 114
- set b 115
- global a b
- list $a $b
- } {114 115}
-
- proc do {cmd} {eval $cmd}
- test proc-3.1 {local and global arrays} {
- catch {unset a}
- set a(0) 22
- list [catch {do {global a; set a(0)}} msg] $msg
- } {0 22}
- test proc-3.2 {local and global arrays} {
- catch {unset a}
- set a(x) 22
- list [catch {do {global a; set a(x) newValue}} msg] $msg $a(x)
- } {0 newValue newValue}
- test proc-3.3 {local and global arrays} {
- catch {unset a}
- set a(x) 22
- set a(y) 33
- list [catch {do {global a; unset a(y)}; array names a} msg] $msg
- } {0 x}
- test proc-3.4 {local and global arrays} {
- catch {unset a}
- set a(x) 22
- set a(y) 33
- list [catch {do {global a; unset a; info exists a}} msg] $msg \
- [info exists a]
- } {0 0 0}
- test proc-3.5 {local and global arrays} {
- catch {unset a}
- set a(x) 22
- set a(y) 33
- list [catch {do {global a; unset a(y); array names a}} msg] $msg
- } {0 x}
- catch {unset a}
- test proc-3.6 {local and global arrays} {
- catch {unset a}
- set a(x) 22
- set a(y) 33
- do {global a; do {global a; unset a}; set a(z) 22}
- list [catch {array names a} msg] $msg
- } {0 z}
- test proc-3.7 {local and global arrays} {
- proc t1 {args} {global info; set info 1}
- catch {unset a}
- set info {}
- do {global a; trace var a(1) w t1}
- set a(1) 44
- set info
- } 1
- test proc-3.8 {local and global arrays} {
- proc t1 {args} {global info; set info 1}
- catch {unset a}
- trace var a(1) w t1
- set info {}
- do {global a; trace vdelete a(1) w t1}
- set a(1) 44
- set info
- } {}
- test proc-3.9 {local and global arrays} {
- proc t1 {args} {global info; set info 1}
- catch {unset a}
- trace var a(1) w t1
- do {global a; trace vinfo a(1)}
- } {{w t1}}
- catch {unset a}
-
- test proc-3.1 {arguments and defaults} {
- proc tproc {x y z} {
- return [list $x $y $z]
- }
- tproc 11 12 13
- } {11 12 13}
- test proc-3.2 {arguments and defaults} {
- proc tproc {x y z} {
- return [list $x $y $z]
- }
- list [catch {tproc 11 12} msg] $msg
- } {1 {no value given for parameter "z" to "tproc"}}
- test proc-3.3 {arguments and defaults} {
- proc tproc {x y z} {
- return [list $x $y $z]
- }
- list [catch {tproc 11 12 13 14} msg] $msg
- } {1 {called "tproc" with too many arguments}}
- test proc-3.4 {arguments and defaults} {
- proc tproc {x {y y-default} {z z-default}} {
- return [list $x $y $z]
- }
- tproc 11 12 13
- } {11 12 13}
- test proc-3.5 {arguments and defaults} {
- proc tproc {x {y y-default} {z z-default}} {
- return [list $x $y $z]
- }
- tproc 11 12
- } {11 12 z-default}
- test proc-3.6 {arguments and defaults} {
- proc tproc {x {y y-default} {z z-default}} {
- return [list $x $y $z]
- }
- tproc 11
- } {11 y-default z-default}
- test proc-3.7 {arguments and defaults} {
- proc tproc {x {y y-default} {z z-default}} {
- return [list $x $y $z]
- }
- list [catch {tproc} msg] $msg
- } {1 {no value given for parameter "x" to "tproc"}}
- test proc-3.8 {arguments and defaults} {
- list [catch {
- proc tproc {x {y y-default} z} {
- return [list $x $y $z]
- }
- tproc 2 3
- } msg] $msg
- } {1 {no value given for parameter "z" to "tproc"}}
- test proc-3.9 {arguments and defaults} {
- proc tproc {x {y y-default} args} {
- return [list $x $y $args]
- }
- tproc 2 3 4 5
- } {2 3 {4 5}}
- test proc-3.10 {arguments and defaults} {
- proc tproc {x {y y-default} args} {
- return [list $x $y $args]
- }
- tproc 2 3
- } {2 3 {}}
- test proc-3.11 {arguments and defaults} {
- proc tproc {x {y y-default} args} {
- return [list $x $y $args]
- }
- tproc 2
- } {2 y-default {}}
- test proc-3.12 {arguments and defaults} {
- proc tproc {x {y y-default} args} {
- return [list $x $y $args]
- }
- list [catch {tproc} msg] $msg
- } {1 {no value given for parameter "x" to "tproc"}}
-
- test proc-4.1 {variable numbers of arguments} {
- proc tproc args {return $args}
- tproc
- } {}
- test proc-4.2 {variable numbers of arguments} {
- proc tproc args {return $args}
- tproc 1 2 3 4 5 6 7 8
- } {1 2 3 4 5 6 7 8}
- test proc-4.3 {variable numbers of arguments} {
- proc tproc args {return $args}
- tproc 1 {2 3} {4 {5 6} {{{7}}}} 8
- } {1 {2 3} {4 {5 6} {{{7}}}} 8}
- test proc-4.4 {variable numbers of arguments} {
- proc tproc {x y args} {return $args}
- tproc 1 2 3 4 5 6 7
- } {3 4 5 6 7}
- test proc-4.5 {variable numbers of arguments} {
- proc tproc {x y args} {return $args}
- tproc 1 2
- } {}
- test proc-4.6 {variable numbers of arguments} {
- proc tproc {x missing args} {return $args}
- list [catch {tproc 1} msg] $msg
- } {1 {no value given for parameter "missing" to "tproc"}}
-
- test proc-5.1 {error conditions} {
- list [catch {proc} msg] $msg
- } {1 {wrong # args: should be "proc name args body"}}
- test proc-5.2 {error conditions} {
- list [catch {proc tproc b} msg] $msg
- } {1 {wrong # args: should be "proc name args body"}}
- test proc-5.3 {error conditions} {
- list [catch {proc tproc b c d e} msg] $msg
- } {1 {wrong # args: should be "proc name args body"}}
- test proc-5.4 {error conditions} {
- list [catch {proc tproc \{xyz {return foo}} msg] $msg
- } {1 {unmatched open brace in list}}
- test proc-5.5 {error conditions} {
- list [catch {proc tproc {{} y} {return foo}} msg] $msg
- } {1 {procedure "tproc" has argument with no name}}
- test proc-5.6 {error conditions} {
- list [catch {proc tproc {{} y} {return foo}} msg] $msg
- } {1 {procedure "tproc" has argument with no name}}
- test proc-5.7 {error conditions} {
- list [catch {proc tproc {{x 1 2} y} {return foo}} msg] $msg
- } {1 {too many fields in argument specifier "x 1 2"}}
- test proc-5.8 {error conditions} {
- catch {return}
- } 2
- test proc-5.9 {error conditions} {
- list [catch {global} msg] $msg
- } {1 {wrong # args: should be "global varName ?varName ...?"}}
- proc tproc {} {
- set a 22
- global a
- }
- test proc-5.10 {error conditions} {
- list [catch {tproc} msg] $msg
- } {1 {variable "a" already exists}}
- test proc-5.11 {error conditions} {
- catch {rename tproc {}}
- catch {
- proc tproc {x {} z} {return foo}
- }
- list [catch {tproc 1} msg] $msg
- } {1 {invalid command name "tproc"}}
- test proc-5.12 {error conditions} {
- proc tproc {} {
- set a 22
- error "error in procedure"
- return
- }
- list [catch tproc msg] $msg
- } {1 {error in procedure}}
- test proc-5.13 {error conditions} {
- proc tproc {} {
- set a 22
- error "error in procedure"
- return
- }
- catch tproc msg
- set errorInfo
- } {error in procedure
- while executing
- "error "error in procedure""
- (procedure "tproc" line 3)
- invoked from within
- "tproc"}
- test proc-5.14 {error conditions} {
- proc tproc {} {
- set a 22
- break
- return
- }
- catch tproc msg
- set errorInfo
- } {invoked "break" outside of a loop
- while executing
- "tproc"}
- test proc-5.15 {error conditions} {
- proc tproc {} {
- set a 22
- continue
- return
- }
- catch tproc msg
- set errorInfo
- } {invoked "continue" outside of a loop
- while executing
- "tproc"}
- test proc-5.16 {error conditions} {
- proc foo args {
- global fooMsg
- set fooMsg "foo was called: $args"
- }
- proc tproc {} {
- set x 44
- trace var x u foo
- while {$x < 100} {
- error "Nested error"
- }
- }
- set fooMsg "foo not called"
- list [catch tproc msg] $msg $errorInfo $fooMsg
- } {1 {Nested error} {Nested error
- while executing
- "error "Nested error""
- ("while" body line 2)
- invoked from within
- "while {$x < 100} {
- error "Nested error"
- }"
- (procedure "tproc" line 4)
- invoked from within
- "tproc"} {foo was called: x {} u}}
-
- # The tests below will really only be useful when run under Purify or
- # some other system that can detect accesses to freed memory...
-
- test proc-6.1 {procedure that redefines itself} {
- proc tproc {} {
- proc tproc {} {
- return 44
- }
- return 45
- }
- tproc
- } 45
- test proc-6.2 {procedure that deletes itself} {
- proc tproc {} {
- rename tproc {}
- return 45
- }
- tproc
- } 45
-
- proc tproc code {
- return -code $code abc
- }
- test proc-7.1 {return with special completion code} {
- list [catch {tproc ok} msg] $msg
- } {0 abc}
- test proc-7.2 {return with special completion code} {
- list [catch {tproc error} msg] $msg $errorInfo $errorCode
- } {1 abc {abc
- while executing
- "tproc error"} NONE}
- test proc-7.3 {return with special completion code} {
- list [catch {tproc return} msg] $msg
- } {2 abc}
- test proc-7.4 {return with special completion code} {
- list [catch {tproc break} msg] $msg
- } {3 abc}
- test proc-7.5 {return with special completion code} {
- list [catch {tproc continue} msg] $msg
- } {4 abc}
- test proc-7.6 {return with special completion code} {
- list [catch {tproc -14} msg] $msg
- } {-14 abc}
- test proc-7.7 {return with special completion code} {
- list [catch {tproc gorp} msg] $msg
- } {1 {bad completion code "gorp": must be ok, error, return, break, continue, or an integer}}
- test proc-7.8 {return with special completion code} {
- list [catch {tproc 10b} msg] $msg
- } {1 {bad completion code "10b": must be ok, error, return, break, continue, or an integer}}
- test proc-7.9 {return with special completion code} {
- proc tproc2 {} {
- tproc return
- }
- list [catch tproc2 msg] $msg
- } {0 abc}
- test proc-7.10 {return with special completion code} {
- proc tproc2 {} {
- return -code error
- }
- list [catch tproc2 msg] $msg
- } {1 {}}
- test proc-7.11 {return with special completion code} {
- proc tproc2 {} {
- global errorCode errorInfo
- catch {open _bad_file_name r} msg
- return -code error -errorinfo $errorInfo -errorcode $errorCode $msg
- }
- string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode]
- } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
- while executing
- "open _bad_file_name r"
- invoked from within
- "tproc2"} {posix enoent {no such file or directory}}}
- test proc-7.12 {return with special completion code} {
- proc tproc2 {} {
- global errorCode errorInfo
- catch {open _bad_file_name r} msg
- return -code error -errorcode $errorCode $msg
- }
- string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode]
- } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
- while executing
- "tproc2"} {posix enoent {no such file or directory}}}
- test proc-7.13 {return with special completion code} {
- proc tproc2 {} {
- global errorCode errorInfo
- catch {open _bad_file_name r} msg
- return -code error -errorinfo $errorInfo $msg
- }
- string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode]
- } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
- while executing
- "open _bad_file_name r"
- invoked from within
- "tproc2"} none}
- test proc-7.14 {return with special completion code} {
- proc tproc2 {} {
- global errorCode errorInfo
- catch {open _bad_file_name r} msg
- return -code error $msg
- }
- string tolower [list [catch tproc2 msg] $msg $errorInfo $errorCode]
- } {1 {couldn't open "_bad_file_name": no such file or directory} {couldn't open "_bad_file_name": no such file or directory
- while executing
- "tproc2"} none}
- test proc-7.14 {return with special completion code} {
- list [catch {return -badOption foo message} msg] $msg
- } {1 {bad option "-badOption: must be -code, -errorcode, or -errorinfo}}
-